home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / sys / error.t < prev    next >
Text File  |  1989-06-30  |  8KB  |  223 lines
  1. (herald error (env tsys))
  2.  
  3. ;;; Copyright (c) 1985 Yale University
  4. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  5. ;;; This material was developed by the T Project at the Yale University Computer 
  6. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  7. ;;; and to use it for any purpose is granted, subject to the following restric-
  8. ;;; tions and understandings.
  9. ;;; 1. Any copy made of this software must include this copyright notice in full.
  10. ;;; 2. Users of this software agree to make their best efforts (a) to return
  11. ;;;    to the T Project at Yale any improvements or extensions that they make,
  12. ;;;    so that these may be included in future releases; and (b) to inform
  13. ;;;    the T Project of noteworthy uses of this software.
  14. ;;; 3. All materials developed as a consequence of the use of this software
  15. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  16. ;;;    of acknowledging credit in academic research.
  17. ;;; 4. Yale has made no warrantee or representation that the operation of
  18. ;;;    this software will be error-free, and Yale is under no obligation to
  19. ;;;    provide any services, by way of maintenance, update, or otherwise.
  20. ;;; 5. In conjunction with products arising from the use of this material,
  21. ;;;    there shall be no use of the name of the Yale University nor of any
  22. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  23. ;;;    without prior written consent from Yale in each case.
  24. ;;;
  25.  
  26. ;++ Someday we should include an explanitory index of error messages
  27. ;++ in the manual.  In order to do this the errors should have
  28. ;++ reasonably short explanitory names.
  29. ;++
  30. ;++ Errors really want to be printed with a prefix format.  We really
  31. ;++ need something like Water's PP.
  32.  
  33. (define internal-error-notice
  34.   #.(format nil "~%~a~%~a~%~a~%~a~%"
  35.       "****"
  36.       "****    This is an internal error. Please inform the"
  37.       "****    implementors by sending mail to T3-BUGS@YALE."
  38.       "****"))
  39.  
  40. ;;; VM-ERROR is called only inside the Virtual Machine.  It indicates
  41. ;;; that something is seriously amiss.  If the Z-SYSTEM is present
  42. ;;; we try to use it to give an error message.  If an error is
  43. ;;; encountered while the GUARD is set or if the Z-SYSTEM isn't
  44. ;;; present we punt to FATAL-ERROR which does whatever the local-os
  45. ;;; allows.
  46.  
  47.  
  48. (define vm-error
  49.   (let ((guard  nil)
  50.         (notice? '#t))
  51.     (lambda (type fmt . args)
  52.       (cond ((and (z-system-present?) (not guard))
  53.              (bind ((*z?*  t)
  54.                     (guard t))
  55.                (let ((out (error-output)))
  56.                  (z-format out "~%** VM Error (~a): " type)
  57.                  (apply z-format out fmt args)
  58.                  (if notice? (vm-write-string out internal-error-notice))
  59.                  (vm-force-output out)))
  60.              (bind ((notice? '#f))
  61.                (z-breakpoint)))
  62.             (else
  63.              ;; punt to the machine debugger
  64.              (let ((out (error-output)))
  65.                (vm-newline out)
  66.                (vm-write-string out "** VM Error while reporting error!")
  67.                (vm-write-string out internal-error-notice)
  68.                (fatal-error)))))))
  69.  
  70. ;++ Move this to the local os hardware exception module.
  71.  
  72. ;++ When the system is more robust (VM-ERROR-OUTPUT) should be
  73. ;++ a broadcast port which writes both to (ERROR-OUTPUT) and to
  74. ;++ (VM-ERROR-LOG) a file in the (THE-T-SYSTEM-DIRECTORY).
  75. ;++ A log entry should consist of (VM-VERSION), (DATE&TIME),
  76. ;++ and any arguments to the call to VM-LOG.
  77.  
  78. ;(define (vm-log . args)
  79. ;  (apply vm-write (vm-error-log) (vm-version) (date&time) args))
  80.  
  81. ;;; Fatal error
  82. ;++ This routine should go to the machine debugger if it can.
  83. ;++ Someday maybe it will do a core dump (and/or checkpoint).
  84.  
  85. (define (fatal-error) (exit))
  86.  
  87. ;;; This error is called if a hardware exception occurs while control
  88. ;;; is inside the critical region of the hardware exception handler.
  89. ;;; See the local os hardware exception module.
  90.  
  91. ;;;  Errors detected by ICALL 
  92.  
  93. (define (icall-bad-proc . args)
  94.   (let* ((p (system-global slink/p))
  95.      (proc (or (identification p) p))
  96.          (fmt  (cond ((not (reasonable? proc))
  97.                       "attempt to call a corrupt datum~%**~10t~s")
  98.                      ((symbol? proc)               ; Cater to the confused
  99.                       "attempt to call a symbol or nonvalue~%**~10t~s")
  100.                      (else 
  101.                       "attempt to call a non-procedure~%**~10t~s"))))
  102.     (apply (error fmt (cons proc args)) args)))
  103.  
  104. (define (icall-wrong-nargs . args)
  105.   (let* ((p (system-global slink/p))
  106.      (n     (car (argspectrum p)))
  107.          (nary? (cdr (argspectrum p)))
  108.          (id    (cond ((identification p))
  109.                       (else
  110.                        (format nil "#{object internal to ~a}"
  111.                                (get-proc-name (extend-header p)))))))
  112.     (error (list "wrong number of arguments to procedure -~%"
  113.                  "**~10t~a~%**~10t~a takes~a ~a argument~p.~%")
  114.            (cons id args)
  115.            id
  116.            (if nary? " at least" "")
  117.            n
  118.            n)))
  119.  
  120. (define (cont-wrong-nargs . args)
  121.   (let* ((link (system-global slink/p))
  122.      (m     (length args))
  123.          (n     (template-nargs link))
  124.          (nary? (template-nary? link)))
  125.     (error "returned ~a value~p when~a ~a ~a expected -~%**~10t~s~%"
  126.            m            
  127.            m
  128.            (if nary? " at least" "")
  129.            n
  130.            (if (fx= n 1) "was" "were")
  131.            (cons (or (template-definer link) link) args))))
  132.  
  133. (define (apply-too-many-args proc) 
  134.   (nc-error "exceeded maximum number of arguments while applying ~a"
  135.             proc))
  136.  
  137. (define (handle-undefined-effect string template)
  138.   (nc-error "undefined effect - ~a ~%**~10tin procedure ~s~%"
  139.             string
  140.             (or (get-proc-name template) 'anonymous)))
  141.  
  142. (define (heap-overflow-error)
  143.   (nc-error "heap overflow"))
  144.  
  145. (define (undefined-effect . stuff)
  146.   (error "call to ~s~%  ~s" 'undefined-effect `(undefined-effect . ,stuff)))
  147.  
  148. (define (error fmt . args)
  149.   (if (not *z?*)
  150.       (signal-error *unspecific-error-type* fmt args)
  151.       (apply vm-error 'Z fmt args)))
  152.  
  153. (define (non-continuable-error fmt . args)
  154.   (if (not *z?*)
  155.       (signal-error *non-continuable-error-type* fmt args)
  156.       (apply vm-error 'ZNC fmt args))
  157.   (not-continuable))
  158.  
  159. (define nc-error non-continuable-error)
  160.  
  161. (define (not-continuable)
  162.   (error "The error you encountered is not continuable.")
  163.   (breakpoint)
  164.   (not-continuable))
  165.  
  166.  
  167. ;;; Warnings.
  168.  
  169. (define (warning fmt . args)
  170.   (let* ((flag (warn))
  171.          (out  (cond ((false? flag) (null-port))
  172.                      (else          (error-output)))))
  173.     (format out "~&;** Warning: ")
  174.     (apply format out fmt args)
  175.     (fresh-line out)
  176.     (if (eq? flag 'break) (breakpoint) (no-value))))
  177.  
  178. ;;; Three settings true, false, or 'BREAK.
  179.  
  180. ;++ need a better name, maybe break-on-warning
  181. (define-simple-switch warn
  182.   (lambda (val)
  183.     (or (eq? val '#f) (eq? val '#t) (eq? val 'break)))
  184.   '#t)
  185.  
  186. ;;; Language level errors.
  187.  
  188. (define (losing-xcond)
  189.   (error "no clause selected in ~s expression" 'xcond))
  190.  
  191. (define (losing-xcase)
  192.   (error "no clause selected in ~s expression" 'xcase))
  193.  
  194. (define (losing-xselect)
  195.   (error "no clause selected in ~s expression" 'xselect))
  196.  
  197.  
  198. ;;; Undefined values
  199.  
  200. (define (undefined-value . stuff)
  201.   (cond ((null? stuff)
  202.          ;; Don't close over STUFF
  203.          (object nil
  204.                  ((print self port)
  205.                   (format port "#{Undefined-value~_~a}"
  206.                           (object-hash self)))))
  207.         (else
  208.          (object nil
  209.                  ((print self port)
  210.                   (format port "#{Undefined-value~_~a"
  211.                           (object-hash self))
  212.                   (walk (lambda (x) (format port "~_~a" x))
  213.                         stuff)
  214.                   (write-char port #\}))))))
  215.  
  216.  
  217. (define undefined-if-value      (undefined-value "undefined IF value"))
  218. (define unbound-label           (undefined-value "unbound label"))
  219. (define let-missing-initializer (undefined-value "LET missing initializer"))
  220. (define no-more-cond-clauses    (undefined-value "no more COND clauses"))
  221. (define case-fell-off-end       (undefined-value "CASE fell off end"))
  222. (define select-fell-off-end     (undefined-value "SELECT fell off end"))
  223.